
; Test cases for the I/O instructions

(define *temporary-output-file* "/tmp/s48-vm-test.txt")
(define *temporary-image-file*  "/tmp/s48-vm-test.image")

(define (open-test-channel filename mode)
  (call-with-exception-handler (enum op open-channel)
    (lambda (opcode reason . args)  ; open-channel raises exceptions if it fails               
      (write-string "open-channel raised exception: ")
      (write-string (symbol->string (enumerand->name reason exception)))
      (write-string " args = ")
      (write args)
      (newline)
      #f)
    (lambda () 
      (open-channel (string->low-string filename) 0 mode #f)))) 


; adapted from small.scm
(define *buffer-size* 1)

(define (make-null-output-port) ; accepts anything
  (make-port #f
	     (enum text-encoding-option latin-1)
	     #f
	     (bitwise-ior (arithmetic-shift 1 (enum port-status-options
						    output))
			  (arithmetic-shift 1 (enum port-status-options
						    open-for-output)))
	     #f		; lock
	     #f
	     (make-byte-vector *buffer-size* 0)
	     0 *buffer-size*
	     #f #f))

(define (make-null-input-port) ; always returns spaces
  (make-port #f
	     (enum text-encoding-option latin-1)
	     #f
	     (bitwise-ior (arithmetic-shift 1 (enum port-status-options
						    input))
			  (arithmetic-shift 1 (enum port-status-options
						    open-for-input)))
	     #f		; lock
	     #f
	     (make-byte-vector *buffer-size* 32)
	     0 *buffer-size*
	     #f #f))

(define-syntax port-test
  (syntax-rules ()
    ((port-test operand expr port name op)
     (port-test operand expr (lambda (x) #t) port name op))
    ((port-test operand expr checker port name op)
     (let ((failed? #f))
       (exception-test operand name op
         (lambda (opcode reason . args)
           (cond ((= reason (enum exception buffer-full/empty))
                  (set-port-index! port 0)
                  expr)
                 (else
                  (set! failed? #t)
                  #f)))
         (lambda ()
           (let ((result (checker expr))) 
             (and result
                  (not failed?)))))))))


(define-test-suite io-tests "io-tests" (lambda ()

  ; Ports (bufferd io)
  ; They need exception handlers to function
  ;
  ; We do not have a dynamic environment here with current ports, so
  ; just test the version with an explicit port.
  ;
  (let ((port (make-null-output-port)))  
    (port-test write-byte (write-byte 32 port) port "write-byte" (enum op write-byte))
    (port-test write-char (write-char #\Space port) port "write-char" (enum op write-char)))
  
  (let ((port (make-null-input-port)))      
    (port-test read-byte (read-byte port) (lambda (b) (= b 32)) port "read-byte" (enum op read-byte))
    (port-test peek-byte (peek-byte port) (lambda (b) (= b 32)) port "peek-byte" (enum op peek-byte))    
    (port-test read-char (read-char port) (lambda (c) (char=? c #\Space)) port "read-char" (enum op read-char))
    (port-test peek-char (peek-char port) (lambda (c) (char=? c #\Space)) port "peek-char" (enum op peek-char)))  
   
  ; Channel opcodes (unbuffered, non-blocking i/o)
  ;
  (bool-test channel-parameter (boolean? (channel-parameter (enum channel-parameter-option crlf?))) "channel-parameter" #t)
  
  ; Output-channel
  ;
  (let ((channel (open-test-channel *temporary-output-file*  (enum channel-status-option output))))
       
       (bool-test (not (eq? channel #f)) "open-channel (output)" #t)       
       
       (if channel
         (begin
         
           (bool-test channel? (channel? channel) "channel?" #t)
           (bool-test open-channels-list (list? (open-channels-list)) "open-channels-list" #t)        
                                       
           ; Note: If this fails, this whole test system will probably not work, as channel-maybe-write
           ;   is also used to output all messages. Keep this for kompleetnes anyway.
           (thunk-test channel-maybe-write "channel-maybe-write"
             (lambda ()
               (write-string "channel-maybe-write: ")
               (let loop ((retry 0))
                 (let ((result (channel-maybe-write channel (string->low-string "abdefghijk") 0 10)))
                   (cond ((= retry 10)
                          (write-string "giving up")
                          (newline)
                          #f) ; give up after 10 tries
                         ((eq? result #f)
                          (write-string "retry, ")
                          (loop (+ retry 1))) ; busy, retry
                         ((cell? result) ; os error
                          (write-string "os-error=")
                          (write-number (cell-ref result))
                          (newline)
                          #f)
                         (else
                          (write-string "written: ")
                          (write-number result)
                          (newline)
                          #t))))))            
           
           (newline)
           (write-string "open-channels-list (length): ")
           (write-number (length (open-channels-list)))
           (newline)
           
           (write-string "channel-ready?: ")
           (write (channel-ready? channel))
           (newline)
           
           (write-string "channel-status: ")
           (write (channel-status channel)) ; this is just stored-object-ref, not a separate opcode
           (newline)
                          
           (write-string "channel-abort: ")
           (write (channel-abort channel))
           (newline)           
           
           (write-string "close-channel")
           (newline)
           (close-channel channel)           
           )))
     
  ; Input-channel: This will fail if the above writes failed
  ;
  (let ((channel (open-test-channel *temporary-output-file*  (enum channel-status-option input))))
       
     (bool-test (not (eq? channel #f)) "open-channel (input)" #t)       
       
     (if channel
       (begin
                                 
         (thunk-test channel-maybe-read "channel-maybe-read"
           (lambda ()
             (write-string "channel-maybe-read: ")
             (let ((output (string->low-string "          ")))
               (let loop ((retry 0))
                 (let ((result (channel-maybe-read channel output 0 10 #f)))
                   (cond ((= retry 10)
                          (write-string "giving up")
                          (newline)
                          #f) ; give up after 10 tries
                         ((eq? result #f)
                          (write-string "retry, ")
                          (loop (+ retry 1))) ; busy, retry
                         ((cell? result) ; os error
                          (write-string "os-error=")
                          (write-number (cell-ref result))
                          (newline)
                          #f)
                         ((eof-object? result)
                          (write-string "eof-object")
                          (newline)
                          #t)
                         (else
                          (write-string "read: ")
                          (write-number result)
                          (write-string " => ")
                          (write (low-string->string output result))
                          (newline)
                          #t)))))))            
           
           (newline)
           (write-string "close-channel")
           (newline)
           (close-channel channel)           
           )))
     
     
  (write-string "message:")
  (newline)
  (message '("debug message"))
    
  ; Test write-image-low
  ; This does not work in the VM running in Scheme
  ;
  (if (is-real-vm?)
    (let ((undumpable (make-vector 1000 #f)))
      (write-string "write-image-low: ")
      (write-string *temporary-image-file*)
      (write-string " ")
      (write-image-low
        (string->low-string *temporary-image-file*)
        (lambda (arg in in-encoding out out-encoding error-out error-out-encoding resumer-records)
          (write-string "This is the write-image-low test." out)
          (newline out)
          0)
        (string->low-string "write-image-low test")
        undumpable)
      (let loop ((i 0) (c 0))
        (cond ((= i 1000)
               (write-number c))
              ((vector-ref undumpable i)
               (loop (+ i 1 ) (+ c 1)))
              (else
               (loop (+ i 1) c))))
      (write-string " undumpable objects")
      (newline)))   
          
 ))